(* File MicroC/Contcomp.fs
   A continuation-based (backwards) compiler from micro-C, a fraction of
   the C language, to an abstract machine.  
   sestoft@itu.dk * 2011-11-10

   The abstract machine code is generated backwards, so that jumps to
   jumps can be eliminated, so that tail-calls (calls immediately
   followed by return) can be recognized, dead code can be eliminated, 
   etc.

   The compilation of a block, which may contain a mixture of
   declarations and statements, proceeds in two passes:

   Pass 1: elaborate declarations to find the environment in which
           each statement must be compiled; also translate
           declarations into allocation instructions, of type
           bstmtordec.
  
   Pass 2: compile the statements in the given environments.
 *)

module Contcomp

open System.IO
open Absyn
open Machine

(* The intermediate representation between passes 1 and 2 above:  *)

type bstmtordec =
     | BDec of instr list                  (* 本地变量声明  *)
     | BStmt of stmt                       (* 声明 *)

(* ------------------------------------------------------------------- *)

//执行局部优化的代码生成函数
//INCSP m 的意思是increase stack top by m
//RET m 的意思是pop m and return to s[sp]
//Label lab 是符号标签；伪指令。
//大致的功能就是实现栈的空间操作
let rec addINCSP m1 C : instr list =
    match C with
    | INCSP m2            :: C1 -> addINCSP (m1+m2) C1
    | RET m2              :: C1 -> RET (m2-m1) :: C1
    | Label lab :: RET m2 :: _  -> RET (m2-m1) :: C
    | _                         -> if m1=0 then C else INCSP m1 :: C

//条件跳转
let addLabel C : label * instr list =          (* Conditional jump to C *)
    match C with
    | Label lab :: _ -> (lab, C)
    | GOTO lab :: _  -> (lab, C)
    | _              -> let lab = newLabel() 
                        (lab, Label lab :: C)
//无条件跳转
let makeJump C : instr * instr list =          (* Unconditional jump to C *)
    match C with
    | RET m              :: _ -> (RET m, C)
    | Label lab :: RET m :: _ -> (RET m, C)
    | Label lab          :: _ -> (GOTO lab, C)
    | GOTO lab           :: _ -> (GOTO lab, C)
    | _                       -> let lab = newLabel() 
                                 (GOTO lab, Label lab :: C)

let makeCall m lab C : instr list =
    match C with
    | RET n            :: C1 -> TCALL(m, n, lab) :: C1
    | Label _ :: RET n :: _  -> TCALL(m, n, lab) :: C
    | _                      -> CALL(m, lab) :: C

//作用应该是去除C中的第一个Label及之前的所有的代码
let rec deadcode C =
    match C with
    | []              -> []
    | Label lab :: _  -> C
    | _         :: C1 -> deadcode C1

//添加NOT（s[sp] != 0 ）
let addNOT C =
    match C with
    | NOT        :: C1 -> C1
    | IFZERO lab :: C1 -> IFNZRO lab :: C1 
    | IFNZRO lab :: C1 -> IFZERO lab :: C1 
    | _                -> NOT :: C


//jump is GOTO or RET 把jump通过判断添加进去
let addJump jump C =                    (* jump is GOTO or RET *)
    let C1 = deadcode C
    match (jump, C1) with
    | (GOTO lab1, Label lab2 :: _) -> if lab1=lab2 then C1 
                                      else GOTO lab1 :: C1
    | _                            -> jump :: C1
    
//调用addjump函数，把goto加入进去
let addGOTO lab C =
    addJump (GOTO lab) C

//添加操作符
let rec addCST i C =
    match (i, C) with
    | (0, ADD        :: C1) -> C1
    | (0, SUB        :: C1) -> C1
    | (0, NOT        :: C1) -> addCST 1 C1
    | (_, NOT        :: C1) -> addCST 0 C1
    | (1, MUL        :: C1) -> C1
    | (1, DIV        :: C1) -> C1
    | (0, EQ         :: C1) -> addNOT C1
    | (_, INCSP m    :: C1) -> if m < 0 then addINCSP (m+1) C1
                               else CSTI i :: C
    | (0, IFZERO lab :: C1) -> addGOTO lab C1
    | (_, IFZERO lab :: C1) -> C1
    | (0, IFNZRO lab :: C1) -> C1
    | (_, IFNZRO lab :: C1) -> addGOTO lab C1
    | _                     -> CSTI i :: C


let rec addCSTF i C =
    match (i, C) with
    | _                     -> (CSTF (System.BitConverter.ToInt32(System.BitConverter.GetBytes(float32(i)), 0))) :: C
(* ------------------------------------------------------------------- *)

let rec addCSTC i C =
    match (i, C) with
    | _                     -> (CSTC ((int32)(System.BitConverter.ToInt16(System.BitConverter.GetBytes(char(i)), 0)))) :: C

let rec addCSTB i C =
    match (i, C) with
    | _                     -> if i=false then (CSTI 0) :: C
                               else (CSTI 1) :: C
                                      
                                

// 多态类型 Env 
// 环境Env 是 元组 ("name",data)的列表 
// 值 data可以是任意类型
type 'data Env = (string * 'data) list
//环境查找函数 
//在环境env上查找名称为x的值
let rec lookup env x = 
    match env with 
    | []         -> failwith (x + " not found")
    | (y, v)::yr -> if x=y then v else lookup yr x

(*全局变量具有绝对地址，局部变量具有偏移： *)

type Var = 
    | Glovar of int                   (* 堆栈中的绝对地址          *)
    | Locvar of int                   (*相对地址 *)

//变量环境列表
//变量环境跟踪全局和局部变量，以及跟踪局部变量的下一个可用偏移量

type VarEnv = (Var * typ) Env * int

//函数参数例子:
//void func (int a , int *p)
// 参数声明列表为: [(TypI,"a");(TypP(TypI) ,"p")]

type Paramdecs = (typ * string) list

(* 函数环境列表  
    ”函数名“ ”返回类型“ “参数列表”
*)
type FunEnv = (label * typ option * Paramdecs) Env

type LabEnv = label list

(* Bind declared variable in varEnv and generate code to allocate it: *)
// 绑定varEnv中声明的变量并生成代码来分配它
let allocate (kind : int -> Var) (typ, x) (varEnv : VarEnv) : VarEnv * instr list =
    let (env, fdepth) = varEnv 
    match typ with
    | TypA (TypA _, _) -> failwith "allocate: arrays of arrays not permitted"
     //如果是数组，就分配i个空间，由于fdepth是指向下一个的，所以要加i+1
    | TypA (t, Some i) ->
      let newEnv = ((x, (kind (fdepth+i), typ)) :: env, fdepth+i+1)
      let code = [INCSP i; GETSP; CSTI (i-1); SUB]
      (newEnv, code)
     //如果是其他的类型，只要分配1个空间就可以了
    | _ -> 
      let newEnv = ((x, (kind (fdepth), typ)) :: env, fdepth+1)
      let code = [INCSP 1]
      (newEnv, code)

(* Bind declared parameter in env: *)
//绑定单个声明的变量到变量环境列表中
let bindParam (env, fdepth) (typ, x) : VarEnv = 
    ((x, (Locvar fdepth, typ)) :: env, fdepth+1);

//绑定多个声明的变量到变量环境列表中
let bindParams paras (env, fdepth) : VarEnv = 
    List.fold bindParam (env, fdepth) paras;

(* ------------------------------------------------------------------- *)

(* Build environments for global variables and global functions *)
//创建全局环境 变量环境VarEnv 函数环境FunEnv
let makeGlobalEnvs(topdecs : topdec list) : VarEnv * FunEnv * instr list = 
    let rec addv decs varEnv funEnv = 
        match decs with 
         //如果语句为空，则返回环境
        | [] -> (varEnv, funEnv, [])
        //如果语句列表不为空，则把list的head选取出来进行模式配对
        | dec::decr -> 
          match dec with
          //如果匹配到Vardec（也就是我们定义的变量声明 typ*string <类型+名称>）
          | Vardec (typ, x) ->
            let (varEnv1, code1) = allocate Glovar (typ, x) varEnv
            let (varEnvr, funEnvr, coder) = addv decr varEnv1 funEnv
            (varEnvr, funEnvr, code1 @ coder)
          | Fundec (tyOpt, f, xs, body) ->
            addv decr varEnv ((f, (newLabel(), tyOpt, xs)) :: funEnv)
    //运行函数 
    addv topdecs ([], 0) []
    
(* ------------------------------------------------------------------- *)


let rec breaklab labs =
    match labs with
    | lab :: tr -> lab
    | [] -> failwith "no labs"

let rec continuelab labs =
    match labs with
    | lab1 :: lab2 :: tr ->lab2
    | [] -> failwith "no labs"
    | [ _ ] ->
        failwith "no enough labs"

(*  编译micro-C语句：
    * stmt是要编译的语句
    * varEnv是局部和全局变量环境
    * funEnv是全局功能环境
    * C是stmt代码编译后的代码
*)

let rec cStmt stmt (varEnv : VarEnv) (funEnv : FunEnv) (labEnv : LabEnv) (C : instr list) : instr list = 
    match stmt with
    | If(e, stmt1, stmt2) -> 
      let (jumpend, C1) = makeJump C
      let (labelse, C2) = addLabel (cStmt stmt2 varEnv funEnv labEnv C1)
      cExpr e varEnv funEnv labEnv (IFZERO labelse 
       :: cStmt stmt1 varEnv funEnv labEnv (addJump jumpend C2))
    | While(e, body) ->
      let labbegin = newLabel()
      let labend=newLabel()
      let labEnv=labend::labbegin::labEnv
      let Cond=Label labend :: C
      let (jumptest, C1) = 
           makeJump (cExpr e varEnv funEnv labEnv (IFNZRO labbegin :: Cond))
      addJump jumptest (Label labbegin :: cStmt body varEnv funEnv labEnv C1)

    | DoWhile(body,e) ->
      let labbegin = newLabel()
      let labend=newLabel()
      let labEnv=labend::labbegin::labEnv
      let Cond=Label labend :: C
      let C1=
        cExpr e varEnv funEnv labEnv (IFNZRO labbegin :: Cond)
      Label labbegin :: cStmt body varEnv funEnv labEnv C1

    | For(dec, e, opera,body) -> 
        let labend   = newLabel()
        let labbegin = newLabel()
        let labope   = newLabel()
        let labEnv=labend::labope::labEnv
        let Cend = Label labend :: C
        let (jumptest, C2) =                                                
            makeJump (cExpr e varEnv funEnv labEnv (IFNZRO labbegin :: Cend)) 
        let C3 = Label labope :: cExpr opera varEnv funEnv labEnv (addINCSP -1 C2)
        let C4 = cStmt body varEnv funEnv labEnv C3    
        cExpr dec varEnv funEnv labEnv (addINCSP -1 (addJump jumptest  (Label labbegin :: C4) ) )
    | ForStep(cond,e1,e2,body)->failwith "wait todo"
    //TODO forstep
    | DoUntil(body,e) -> 
      let labbegin = newLabel()
      let labend=newLabel()
      let labEnv=labend::labbegin::labEnv
      let Cond=Label labend :: C
      let C1=
        cExpr e varEnv funEnv labEnv (IFZERO labbegin :: Cond)
      Label labbegin :: cStmt body varEnv funEnv labEnv C1

    | Switch(e,cases)   ->
        let (labend, C1) = addLabel C
        let labEnv = labend::labEnv
        let rec everycase c  = 
            match c with
            | Case(cond,body) :: tr ->
                let (labnextbody,labnext,C2) = everycase tr
                let (label, C3) = addLabel(cStmt body varEnv funEnv labEnv (addGOTO labnextbody C2))
                let (label2, C4) = addLabel( cExpr (Prim2 ("==",e,cond)) varEnv funEnv labEnv (IFZERO labnext :: C3))
                (label,label2,C4)
            | Default( body ) :: tr -> 
                let (labnextbody,labnext,C2) = everycase tr
                let (label, C3) = addLabel(cStmt body varEnv funEnv labEnv (addGOTO labnextbody C2))
                let (label2, C4) = addLabel(cExpr (Prim2 ("==",e,e)) varEnv funEnv labEnv (IFZERO labnext :: C3))
                (label,label2,C4)
            | [] -> (labend, labend,C1)
        let (label,label2,C2) = everycase cases
        C2
    | Case(e,body)-> C
    | Match(e,body)->
        let (labend,C1)= addLabel C
        let labEnv = labend::labEnv
        let rec everymatch list=
          match list with
          | Pattern(e1,body) :: tr->
            let (labnextbody,labnext,C2) = everymatch tr
            let (label, C3) = addLabel(cStmt body varEnv funEnv labEnv (addGOTO labnextbody C2))
            let (label2, C4) = addLabel(cExpr (Prim2 ("==",e,e1)) varEnv funEnv labEnv (IFZERO labnext :: C3))
            (label,label2,C4)
          | [] -> (labend,labend,C1)
          | MatchAll(body):: tr->
            let (labnextbody,labnext,C2) = everymatch tr
            let (label, C3) = addLabel(cStmt body varEnv funEnv labEnv (addGOTO labnextbody C2))
            let (label2, C4) = addLabel(cExpr (Prim2 ("==",e,e)) varEnv funEnv labEnv (IFZERO labnext :: C3))
            (label,label2,C4)
        let (label,label2,C2) = everymatch body
        C2
    | MatchAll(body)->C
    | Pattern(e,body)->C
    | Expr e -> 
      cExpr e varEnv funEnv labEnv (addINCSP -1 C) 
    | Block stmts -> 
      let rec pass1 stmts ((_, fdepth) as varEnv) =
          match stmts with 
          | []     -> ([], fdepth)
          | s1::sr ->
            let (_, varEnv1) as res1 = bStmtordec s1 varEnv
            let (resr, fdepthr) = pass1 sr varEnv1 
            (res1 :: resr, fdepthr) 
      let (stmtsback, fdepthend) = pass1 stmts varEnv
      let rec pass2 pairs C = 
          match pairs with 
          | [] -> C
          | (BDec code,  varEnv) :: sr -> code @ pass2 sr C
          | (BStmt stmt, varEnv) :: sr -> cStmt stmt varEnv funEnv labEnv (pass2 sr C)
      pass2 stmtsback (addINCSP(snd varEnv - fdepthend) C)
    | Return None -> 
      RET (snd varEnv - 1) :: deadcode C
    | Return (Some e) -> 
      cExpr e varEnv funEnv labEnv (RET (snd varEnv) :: deadcode C)
    | Break ->
        let labend = breaklab labEnv
        addGOTO labend C
    | Continue ->
        let labcontinue = continuelab labEnv 
        addGOTO labcontinue C
    | Pass -> C

and bStmtordec stmtOrDec varEnv : bstmtordec * VarEnv =
    match stmtOrDec with 
    | Stmt stmt    ->
      (BStmt stmt, varEnv) 
    | Dec (typ, x) ->
      let (varEnv1, code) = allocate Locvar (typ, x) varEnv 
      (BDec code, varEnv1)

(* Compiling micro-C expressions: 

   * e       is the expression to compile
   * varEnv  is the compile-time variable environment 
   * funEnv  is the compile-time environment 
   * C       is the code following the code for this expression

   Net effect principle: if the compilation (cExpr e varEnv funEnv C) of
   expression e returns the instruction sequence instrs, then the
   execution of instrs will have the same effect as an instruction
   sequence that first computes the value of expression e on the stack
   top and then executes C, but because of optimizations instrs may
   actually achieve this in a different way.
 *)

and cExpr (e : expr) (varEnv : VarEnv) (funEnv : FunEnv) (labEnv: LabEnv) (C : instr list) : instr list =
    match e with
    | Access acc     -> cAccess acc varEnv funEnv labEnv (LDI :: C)
    | Assign(acc, e) -> cAccess acc varEnv funEnv labEnv (cExpr e varEnv funEnv labEnv (STI :: C))
    | CstI i         -> addCST i C
    | CstF f     -> addCSTF f C    
    | CstC c              -> addCSTC c C  
    | CstB b              -> addCSTB b C
    | Addr acc       -> cAccess acc varEnv funEnv labEnv C
    | PrimPrint(ope,e1)->
      cExpr e1 varEnv funEnv labEnv 
          (match ope with
          | 'd' -> PRINTI :: C
          | 'c' -> PRINTC :: C
          | 'f' -> PRINTI :: C
          | 'b' -> PRINTB :: C
          | _        -> failwith "print error")
    | Prim1(ope, e1) ->
      cExpr e1 varEnv funEnv labEnv 
          (match ope with
           | "!"      -> addNOT C
           | _        -> failwith "unknown primitive 1")
    | Prim2(ope, e1, e2) ->
      cExpr e1 varEnv funEnv labEnv 
        (cExpr e2 varEnv funEnv labEnv 
           (match ope with
            | "*"   -> MUL  :: C
            | "+"   -> ADD  :: C
            | "-"   -> SUB  :: C
            | "/"   -> DIV  :: C
            | "%"   -> MOD  :: C
            | ">>"  -> RSH  :: C
            | "<<"  -> LSH  :: C 
            | "=="  -> EQ   :: C
            | "!="  -> EQ   :: addNOT C
            | "<"   -> LT   :: C
            | ">="  -> LT   :: addNOT C
            | ">"   -> SWAP :: LT :: C
            | "<="  -> SWAP :: LT :: addNOT C
            | _     -> failwith "unknown primitive 2"))
    | Prim3(e1,e2,e3)->
      let (jumpend, C1) = makeJump C
      let (labelse, C2) = addLabel (cExpr e3 varEnv funEnv labEnv C1)
      cExpr e1 varEnv funEnv labEnv (IFZERO labelse 
       :: cExpr e2 varEnv funEnv labEnv (addJump jumpend C2))

    | Inc(ope,acc) -> 
      cAccess acc varEnv funEnv labEnv 
        (match ope with
          | "I++" -> (addINCSP -1 (cExpr (Assign (acc,Prim2("+",Access acc, CstI 1))) varEnv funEnv labEnv  (CSTI 1 :: SUB :: C)))
          | "++I" -> (CSTI 1 :: ADD :: (addINCSP -1 (cExpr (Assign (acc,Prim2("+",Access acc, CstI 1))) varEnv funEnv labEnv C))))
    | Decr(ope,acc) -> 
      cAccess acc varEnv funEnv labEnv 
        (match ope with
          | "I--" -> (addINCSP -1 (cExpr (Assign (acc,Prim2("-",Access acc, CstI 1))) varEnv funEnv labEnv (CSTI 1 :: ADD :: C)))
          | "--I" -> (CSTI 1 :: SUB :: (addINCSP -1 (cExpr (Assign (acc,Prim2("-",Access acc, CstI 1))) varEnv funEnv labEnv C))))
    | SelfEqual(ope,acc,e1)->
      cAccess acc varEnv funEnv labEnv 
        (match ope with
          | "+=" -> (CSTI 1 :: ADD :: (addINCSP -1 (cExpr (Assign (acc,Prim2("+",Access acc, e1))) varEnv funEnv  labEnv C)))
          | "-=" -> (CSTI 1 :: SUB :: (addINCSP -1 (cExpr (Assign (acc,Prim2("-",Access acc, e1))) varEnv funEnv  labEnv C)))
          | "*=" -> cExpr (Assign (acc,Prim2("*",Access acc, e1))) varEnv funEnv labEnv (addINCSP -1 C)
          | "/=" -> cExpr (Assign (acc,Prim2("/",Access acc, e1))) varEnv funEnv labEnv (addINCSP -1 C)
          | ">>" -> (CSTI 1 :: DIV :: (addINCSP -1 (cExpr (Assign (acc,Prim2(">>",Access acc, e1))) varEnv funEnv  labEnv C)))
          | "<<" -> (CSTI 1 :: MUL :: (addINCSP -1 (cExpr (Assign (acc,Prim2("<<",Access acc, e1))) varEnv funEnv  labEnv C))))
    | Andalso(e1, e2) ->
      match C with
      | IFZERO lab :: _ ->
         cExpr e1 varEnv funEnv labEnv (IFZERO lab :: cExpr e2 varEnv funEnv labEnv C)
      | IFNZRO labthen :: C1 -> 
        let (labelse, C2) = addLabel C1
        cExpr e1 varEnv funEnv labEnv 
           (IFZERO labelse 
              :: cExpr e2 varEnv funEnv labEnv (IFNZRO labthen :: C2))
      | _ ->
        let (jumpend,  C1) = makeJump C
        let (labfalse, C2) = addLabel (addCST 0 C1)
        cExpr e1 varEnv funEnv labEnv 
          (IFZERO labfalse 
             :: cExpr e2 varEnv funEnv labEnv (addJump jumpend C2))
    | Orelse(e1, e2) -> 
      match C with
      | IFNZRO lab :: _ -> 
        cExpr e1 varEnv funEnv  labEnv (IFNZRO lab :: cExpr e2 varEnv funEnv  labEnv C)
      | IFZERO labthen :: C1 ->
        let(labelse, C2) = addLabel C1
        cExpr e1 varEnv funEnv labEnv 
           (IFNZRO labelse :: cExpr e2 varEnv funEnv labEnv 
             (IFZERO labthen :: C2))
      | _ ->
        let (jumpend, C1) = makeJump C
        let (labtrue, C2) = addLabel(addCST 1 C1)
        cExpr e1 varEnv funEnv labEnv 
           (IFNZRO labtrue 
             :: cExpr e2 varEnv funEnv  labEnv (addJump jumpend C2))
    | Call(f, es) -> callfun f es varEnv funEnv labEnv C

(* Generate code to access variable, dereference pointer or index array: *)

and cAccess (access:access) (varEnv:VarEnv) (funEnv:FunEnv) (labEnv:LabEnv) (C:instr list) = 
    match access with 
    | AccVar x   ->
      match lookup (fst varEnv) x with
      | Glovar addr, _ -> addCST addr C
      | Locvar addr, _ -> GETBP :: addCST addr (ADD :: C)
    | AccDeref e ->
      cExpr e varEnv funEnv labEnv C
    | AccIndex(acc, idx) ->
      cAccess acc varEnv funEnv labEnv (LDI :: cExpr idx varEnv funEnv labEnv (ADD :: C))

(* Generate code to evaluate a list es of expressions: *)

and cExprs (es:expr list)(varEnv:VarEnv) (funEnv:FunEnv) (labEnv:LabEnv) (C:instr list) = 
    match es with 
    | []     -> C
    | e1::er -> cExpr e1 varEnv funEnv labEnv (cExprs er varEnv funEnv labEnv C)

(* Generate code to evaluate arguments es and then call function f: *)
    
and callfun (f:string) (es:expr list)(varEnv:VarEnv) (funEnv:FunEnv) (labEnv:LabEnv) (C:instr list) : instr list =
    let (labf, tyOpt, paramdecs) = lookup funEnv f
    let argc = List.length es
    if argc = List.length paramdecs then
      cExprs es varEnv funEnv  labEnv (makeCall argc labf C)
    else
      failwith (f + ": parameter/argument mismatch")

(* Compile a complete micro-C program: globals, call to main, functions *)

let cProgram (Prog topdecs) : instr list = 
    let _ = resetLabels ()
    let ((globalVarEnv, _), funEnv, globalInit) = makeGlobalEnvs topdecs
    let compilefun (tyOpt, f, xs, body) =
        let (labf, _, paras) = lookup funEnv f
        let (envf, fdepthf) = bindParams paras (globalVarEnv, 0)
        let C0 = [RET (List.length paras-1)]
        let code = cStmt body (envf, fdepthf) funEnv [] C0
        Label labf :: code
    let functions = 
        List.choose (function 
                         | Fundec (rTy, name, argTy, body) 
                                    -> Some (compilefun (rTy, name, argTy, body))
                         | Vardec _ -> None)
                         topdecs
    let (mainlab, _, mainparams) = lookup funEnv "main"
    let argc = List.length mainparams
    globalInit 
    @ [LDARGS; CALL(argc, mainlab); STOP] 
    @ List.concat functions

(* Compile the program (in abstract syntax) and write it to file
   fname; also, return the program as a list of instructions.
 *)

let intsToFile (inss : int list) (fname : string) = 
    File.WriteAllText(fname, String.concat " " (List.map string inss))

let contCompileToFile program fname = 
    let instrs   = cProgram program 
    let bytecode = code2ints instrs
    intsToFile bytecode fname; instrs

(* Example programs are found in the files ex1.c, ex2.c, etc *)
